Mac Mania 2/MacMania 2.toast/Demo's/Tools&Utilities/Programming/MacStarter Pascal 1.0/xWindows definition files/expression.p

Text File | 1993-12-11 | 63.6 KB | 2,084 lines | [TEXT/PJMM]

{ Expressions.p, version 1.0, released December 1993. }

{ by David J. Eck }
{      Department of Mathematics }
{      Hobart and William Smith Colleges }
{      Geneva, NY 14456 }
{      E-mail:  [e-mail] }

{ This unit can be used in any way, except that: }
{        (1)  If you distribute the SOURCE CODE, you cannot charge for it. }
{        (2)  If you distribute the source code, modified or unmodified, it must }
{                include the preamble containing my name and address and this restriction, }
{                and it must include a note of any changes made. }
{ Note that there is no restriction on distributing programs you write using }
{ this unit, or even charging for them. }

{ This unit has been tested, but not sufficiently to reveal all errors.  I would be }
{ happy to receive reports of problems.  However, the unit is provided with no }
{ guarantee of correctness or usefulness. }



unit expression;

{ This unit defines a class EXPRESSION that implements mathematical expressions, }
{ along with a number of supporting utility procedures.  Flexibility is provided by }
{ some Boolean variables which can be set to determine the exact behavior of the }
{ unit. }

{ IMPORTANT NOTE:  If you want to use this unit in a program you MUST include a }
{                              call to the procedure InitExpressions in the initialization }
{                              section of your program. }


{ SPECS:  1)  Expressions can include the operators:  +, -, *, /, and ^. }
{              2)  The available built-in functions are:  sin, cos, tan, cot, csc, sec, }
{                          arcsin,arctan,exp,ln,sqrt,cubert,abs,round,trunc. }
{              3)   By default, brackets and braces can be used, as well as parentheses. }
{                         (You can turn off this option.) }
{              4)  Options that you can turn on include:  factorials, split functions, }
{                         and multiplication by juxtaposition instead of * }
{              5)  You can have user-defined functions with up to 10 arguments. }
{              6)  The word "pi" is reserved to mean the constant π. (The symbol π itself }
{                         can also be used in expressions. }
{              7)  For more information, see the boolean OPTIONS defined below. }


interface

const

    symbolNameMaxLength = 20;   { This is the longest a variable or function name can }
          { be; extra characters in a name are discarded on input.  This must be at least }
          { 6 in order to support the names of the standard functions. }

    infinity = 1e2000;   { The value of an expression that is undefined will be either }
    errorVal = 1e2001;  {      infinity or errorVal;  errorVal is used when an input }
                                  {      value is not in the domain of a function. }
    infinityRecip = 1e-2000;  { Just for convenience; must be set to 1/infinity }



{-------------------- Definition of the class Expression ------------------------}

type

    expression = object
            data: handle;  { An encoding of the actual expression, really of type }
                            { ExpressionListHandle, which is hidden in the implementation }
                            { section of this unit.  YOU SHOULD NOT do anything with the }
                            { instance variables of an expression. }
            count: integer;    { number of nodes in the ExpressionListHandle }
            first: integer;     { the number of the "root" node in the ExpressionListHandle }
            procedure createFromString (definition: string;
                                        var errorPosition: integer;
                                        var errorMessage: string);
          { This is the most common way of creating an expression.  The function is }
          { simply defined from the specified string (such as '3*x-sin(y^2)').  If no }
          { error occurs, then the expression is defined and errorPosition is set to -1 }
          { If an error occurs, then errorPosition is set to the position in the string }
          { where the error was found, and errorMessage is set to a string that }
          { describes the error. }
            procedure createFromText (definition: CharsHandle;
                                        var errorPosition: integer;
                                        var errorMessage: string);
          { A limitation on createFromString is that it cannot deal with a definition }
          { containing more than 255 characters.  If that is a problem, you can use }
          { createFromText instead.  Here, the definition is contained in a CharsHandle, }
          { which is a handle to an array of characters that can be of any length. }
          { Some utility procedures are provided below for manipulating CharsHandles. }
            procedure create (definition: ptr;       { pointer to array[0..(charCount-1)] of char }
                                        charCount: integer;
                                        var errorPosition: integer;
                                        var errorMessage: string);
          { This is the basic expression creation procedure, but you probably won't use it }
          { directly; calls to createFromString and createFromText are translated into }
          { calles to this procedure. }
            procedure GetPrintString (var str: string;
                                        var lengthExceeded: boolean);
          { Returns a string representation of the expression.  (This is not necessarily }
          { identical to the string used to create the expression.)   It is possible that }
          { the expression would require more than the 255 character maximum allowed }
          { in a string;  in that case, the parameter lengthExceeded is set to true, and the }
          { first 255 characters are returned in str. }
            procedure GetPrintText (var theText: CharsHandle);
          { Returns a text representation of the string; here, there is no length maximum. }
          { Note: theText must already exist as a handle; you can create a handle using the }
          {          procedure NewChars defined below. }
            procedure kill;
          { Dispose of all storage associated to the expression.  After a call to }
          { "expr.kill" any reference to expr is invalid.  You can reuse the variable }
          { expr by calling new(expr) again first. }
            function value: extended;
          { Returns the value of the expression. }
            function valueWithCases (var cases: handle): extended;
          { This function also returns the value of the expressions, but every time it }
          { evaluates a discontinuous function, it records which branch of the function }
          { was used in the handle, cases.  You can then compare the "cases" from two }
          { successive evaluations of the expression using the procedure SameCases }
          { defined below.  If sameCases is false, it is possibly a discontinuity.  This }
          { is meant for use in graphing functions, and is really a fudge. }
          { NOTE: cases must already exist as a handle when this procedure is called; }
          { You can create a handle with:  cases := NewHandle(0) }
            function isConstant: boolean;
          { Test if this is a constant expression }
        end;


{------------------------------ OPTIONS ----------------------------------}

{ The following boolean variables are all set to FALSE by the procedure InitExpressions. }
{ Their values affect only the parsing of expressions.  For example, if you have defined }
{ a split function, and then you turn the option splitFunctions off, you will still be able }
{ to use the existing split functions (but you won't be able to define new ones). }
{ If you want to change a value, you should ordinarily do so just after calling }
{ InitExpressions.  Of course, you can change the values any time you want in your }
{ program, but you should be careful when you do so for some of them, as noted in the }
{ individual comments.  }

var

    singleLetterVariables: boolean;  { if turned on, this restricts variables in expressions }
         { being parsed to consist of a single character.  Even if longer variables exist in the }
         { symbol table, they will be inaccessible.  }

    implicitMultiplication: boolean;  { if turned on, then multiplication in expressions }
         { being parsed can be indicated implicitely (i.e. by juxtaposition) as well as }
         { explicitely (by "*").  For example , "speed time" will be interpreted as }
         { "speed * time".   Note that a space is still required between speed and time, }
         { since "speedtime" will be interpreted as a single variable.  However, if you }
         { also turn on the option singleLetterVariables, then things like "2xy" will be }
         { correctly interpreted (as "2*x*y"). }

    autoDeclareVariables: boolean;   { by default, when an unknown symbol is encountered }
         { in an expression being parsed, it is considered to be an error.  If you turn on this }
         { option, however, any unknown symbol will be automatically declared to be a }
         { variable with an initial value of 0 }

    splitFunctions: boolean;    { if this option is turned on, it is possible to define "split }
         { functions" which have different defintions on different parts of their domain. }
         { The notation for a split function is: }
         {        CASE <condition> : <expression> ;  <condition> : <value> ;  . . . END }
         { For example:    "case  x>0: ln(x);  x<=0: 1 end"    (The final ; is optional.) }
         { Example function definition:  "max(a,b) = CASE  a>b:  a;  a<=b:  b;  END" }
         { When this option is turned on, the words CASE and END are RESERVED.  That is }
         { they cannot be used for any other purpose except to define split functions. }
         { (Varialbles or functions named case or end will be inaccessible.) }

    parenthesesOnly: boolean;  { by default, brackets and set braces can be used in }
         { expressions being parsed.  Matching of left bracket to right bracket and left }
         { brace to right brace is enforced, as well as matching of left parenthesis to }
         { right parenthesis.  If you turn on this option, only parentheses will be allowed. }

    allowFactorials: boolean;   { If you turn on this option, then the factorial operator }
         { can appear in expressions being parsed.  The notation is the usual one  (for }
         { example:  n! ).  When factorials are evaluated, the operand must be a non- }
         { negative integer, or an error occurs. }

    caseSensitive: boolean;   { By default, upper case and lower case letters are considered }
         { to be the same during string comparisons.  For example, sin(X), Sin(x) and }
         { SIN(x) all mean the same thing.  If you want case to matter, you can turn on this }
         { option.   If you do, note that the standard functions are written in lower case. }

    extraDataAfterExpression: boolean;  { Ordinarily, an error occurs if extra data is }
         { found in the input after the expression is fully parsed.  Turn on this option if }
         { you don't want this to be an error. }


{---------------------------- Procedures ----------------------------------}

procedure initExpressions;
{ This procedure MUST be called before any of the other procedures in the unit are}
{ used.  It initializes the symbol table and defined all the built-in functions, as }
{ well as the constant e. }

procedure DefineFunctionFromString (definition: string;
                            var errorPos: integer;
                            var errorMessage: string);
{ The definition should be a string of the form "<name> (<arguments>) = <expression>" }
{ (for example, like 'f(x,y)=3*x-sin(y)').  The equals sign is actually optional. }
{ This inserts a function <name> into the symbol table with the specified definition.  }
{ The function can then be used in subsequent expressions.  You can't redefine a }
{ built-in function, and you can't redefine a variable or symbolic constant as a }
{ function.  You CAN redefine an existing function, PROVIDED there is the same number }
{ of arguments in the new definition as in the old;  if you do redefine a function, any }
{ expression that refers to that function will also be effectively changed. }
{ If the definition is successful, errorPos is set to -1;  if an error occurs, errorPos }
{ is set to indicate the position of the error in the string, and errorMessage is set to }
{ a string describing the error. }

procedure DefineFunctionFromText (definition: CharsHandle;
                            var errorPos: integer;
                            var errorMessage: string);
{ This allows you to define functions when the definition is longer than 255 characters; }
{ here, the defintion is given as a CharsHandle; otherwise, the description of this }
{ routine is the same as that of DefineFunctionFromString. }

procedure DefineFunction (definition: Ptr;
                            charCt: integer;
                            var errorPos: integer;
                            var errorMessage: string);
{ The basic function definition procedure, which you will probably have no reason to }
{ use.  Calls to DefineFunctionFromText and DefineFunctionFromString are translated }
{ into calls to this procedure. }

function CreateVariable (name: string;
                            val: extended): integer;
{ Add a variable of the specified name, with the specified initial value, to the }
{ symbol table.  Thereafter, the variable can be used in expressions.  This functions }
{ returns an integer that can be used subsequently to refer to the variable in the procedures }
{ SetVariableName and SetVariableValue.  If some error occurs in defining the variable, }
{ then a value of -1 is returned by the function.  It is an error to try to redefine an }
{ existing symbol.  It is also conceivable (though very unlikely) that an error will }
{ occur because you have run out of memory. }

procedure SetVariableValue (varRef: integer;
                            val: extended);
{ Change the value of an existing variable.  varRef must be a value returned by the }
{ procedure CreateVariable when the variable was first created. }

procedure SetVariableName (varRef: integer;
                            name: string);
{ Change the name of an existing variable.  This procedure does no error checking }
{ (so that you could, for example, make two variables have the same name!).  Use this }
{ procedure only in limited circumstances.  For example, if your program uses only }
{ one or a few variables, and you know what all their names are. }

procedure CreateSymbolicConstant (name: string;
                            value: extended;
                            var err: boolean);
{ Creates a "symbolic constant", which is like a variable except that its value can't be }
{ changed.  The symbolic constant  e  is built in.  (π is also built in, although by a }
{ slightly different mechanism, which allows it to be referred to as either π or pi. ) }

function sameCases (cases1, cases2: handle): boolean;
{ compares two handles returned by the function expression.valueWithCases; if the }
{ answer is false, it is possible that there is a "discontinuity" between the two }
{ evaluations of the expression.  See the comment on function valueWithCases above. }

procedure RealToString (x: extended;
                            var s: string);
{ Utility procedure for reasonable string representation of a real number.  The string }
{ will not be longer than 12 characters. }

function NewChars: CharsHandle;
{ Utility procedure for initializing a CharsHandle; All of the above procedures that }
{ use CharsHandles require that their parameter already be initialized when the }
{ procedure is called; the initial lenght of the array is 0. }

function CharsSize (Chars: CharsHandle): longint;
{ Utility procedure for checking how many characters there are in the array }
{ pointed to by the handle Chars. }
{ Chars must already be initialized, for example by using function NewChars. }

procedure MakeCharsEmpty (var Chars: CharsHandle);
{ Utility procedur for resetting the length of the array pointed to by Chars to 0. }
{ Chars must already be initialized, for example by using function NewChars. }

procedure AddStringToChars (var Chars: CharsHandle;
                            str: string);
{ Utility procedure for adding the characters in the string str onto the end of the }
{ array of characters pointed to by Chars. }
{ Chars must already be initialized, for example by using function NewChars. }



implementation


{----------------------- Type definitions for expressions --------------------}

type

    ExpressionNodeKinds = ( { types of nodes in the binary tree reprsenting an expression}
        binOpNode, {represents an operator with two operands}
        unaryOpNode, {unary minus or built-in function}
        functNode, {call to user-defined function}
        splitFunctionNode, {represents a sub-expression together with a boolean condition on}
                       {  the domain;  this is also used to implement "split" functions in which }
                       {  different definitinons are given on different domains }
        variableNode, {represents a variable  }
        parameterNode, { ref to a param in a user-defined function; appear only in }
                             { the definitions associated with user functions }
        actualParamNode,  { an actual parameter in a function call (a sub expression) }
        symbolicConstantNode, { reference to a defined constant, such as e }
        constantNode, { an actual numeric constant }
        piNode { ref to the constant π }
        );

    binOpKinds = (plusOp, minusOp, timesOp, divideOp, powerOp, andOp, orOp, leOp, ltOp, geOp, gtOp, eqOp, neOp);
    unaryOpKinds = (unaryMinusOp, notOp, sinOp, cosOp, tanOp, cotOp, secOp, {}
        cscOp, arcsinOp, arctanOp, expOp, lnOp, roundOp, truncOp, sqrtOp,{}
        cubeRtOp, absOp, factorialOp);

    ExpressionNode = record      { one of the nodes in the binary tree rep. of an expression }
            bracket: char;  { parenthesis, brace, or bracket (or space, for no bracket) }
            case kind : ExpressionNodeKinds of
                binOpNode: (    { operator and operands}
                        theBinOp: binOpKinds;
                        operand1, operand2: integer;  { static pointers to operands }
                );
                unaryOpNode: (   {operator/function and operand/argument}
                        theOp: unaryOpKinds;
                        operand: integer;   { static pointer }
                );
                functNode: (   { pointer into list of functions; static pointer to argument }
                        definition: integer;    { position of definition in symbolTable }
                        firstArgument: integer;   { ref to first actual parameter; -1 is no params }
                );
                splitFunctionNode: (
                        theExpression, theTest: integer;   { pointer to subexpression and domain cond.}
                        nextCase: integer;      { for a split function, the next case subexpression }
                );
                variableNode, symbolicConstantNode: (
                        symbol: integer;   { pointer into symbol table }
                );
                parameterNode: (
                        number: integer
                );
                actualParamNode: (
                        param: integer;
                        nextArgument: integer;
                );
                constantNode: (
                        value: extended
                );
                piNode: (
                )
        end;

    ExpressionListArray = array[0..1000] of ExpressionNode;  { data for expression is stored }
    ExpressionListPtr = ^ExpressionListArray;   { as a binary tree using static pointers in a}
    ExpressionListHandle = ^ExpressionListPtr;{variable-length array of nodes}


{---------------------- SYMBOL TABLE STUFF -------------------- }


type

    symbolTableError = (noSymbolTableError, lowMemory, cantDeleteFunction, symbolDoesNotExist, symbolAlreadyExists);

    symbolTableKinds = (variableSymbol, functionSymbol, constantSymbol, builtInFunctionSymbol, deletedSymbol, parameterSymbol);

    symbolName = string[symbolNameMaxLength];

    symbolTableNode = record
            name: symbolName;
            case kind : symbolTableKinds of
                variableSymbol, constantSymbol: (
                        value: extended
                );
                functionSymbol: (
                        parameterCount: integer;
                        definition: expression
                );
                parameterSymbol: (
                        paramNum: integer
                );
                builtInFunctionSymbol: (
                        theOp: UnaryOpKinds
                );
                deletedSymbol: (
                )
        end;
    symbolTableArray = array[0..100] of symbolTableNode;
    symbolTablePtr = ^symbolTableArray;
    symbolTableHandle = ^symbolTablePtr;

var
    ST: symbolTableHandle;
    ST_size: integer;
    ST_count: integer;
    ST_mark: integer;
    nameChars: set of char;

procedure MarkSymb;
    begin
        if ST_mark < 0 then
            ST_mark := ST_count;
    end;

procedure FreeSymb;
    begin
        if ST_mark >= 0 then
            ST_count := ST_mark;
        ST_mark := -1;
    end;

function FindSymb (name: SymbolName): integer;
    var
        i: integer;
    begin
        for i := ST_count - 1 downto 0 do
            if not (ST^^[i].kind = deletedSymbol) & EqualString(ST^^[i].name, name, caseSensitive, caseSensitive) then begin
                    FindSymb := i;
                    EXIT(FindSymb);
                end;
        FindSymb := -1;
    end;

function CreateSymbol (name: SymbolName;
                                kind: SymbolTableKinds;
                                var err: SymbolTableError): integer;
    var
        loc, i: integer;
    begin
        loc := FindSymb(name);
        if loc <> -1 then begin
                err := symbolAlreadyExists;
                EXIT(CreateSymbol);
            end;
        if (kind <> parameterSymbol) then
            for i := 0 to ST_size - 1 do
                if ST^^[i].kind = deletedSymbol then begin
                        loc := i;
                        leave
                    end;
        if loc = -1 then begin
                if ST_count = ST_size then begin
                        SetHandleSize(Handle(ST), (ST_size + 20) * SizeOf(SymbolTableNode));
                        if memError <> noErr then begin
                                err := lowMemory;
                                EXIT(CreateSymbol);
                            end;
                        ST_size := ST_size + 20;
                    end;
                loc := ST_count;
                ST_count := ST_count + 1;
            end;
        ST^^[loc].name := name;
        ST^^[loc].kind := kind;
        if kind = variableSymbol then
            ST^^[loc].value := 0;
        err := noSymbolTableError;
        CreateSymbol := loc;
    end;


procedure AddBuiltInFunctions;
    var
        junk: boolean;
    procedure Add (op: unaryOpKinds;
                                    name: SymbolName);
        var
            where: integer;
            err: symbolTableError;
        begin
            where := CreateSymbol(name, builtInFunctionSymbol, err);
            if err <> noSymbolTableError then
                EXIT(AddBuiltInFunctions);
            ST^^[where].theOp := op;
        end;
    begin
        Add(sinOp, 'sin');
        Add(cosOP, 'cos');
        Add(tanOP, 'tan');
        Add(cscOP, 'csc');
        Add(secOP, 'sec');
        Add(cotOP, 'cot');
        Add(arcsinOP, 'arcsin');
        Add(arctanOP, 'arctan');
        Add(expOP, 'exp');
        Add(lnOP, 'ln');
        Add(roundOP, 'round');
        Add(truncOP, 'trunc');
        Add(sqrtOP, 'sqrt');
        Add(cubertOP, 'cubert');
        Add(absOP, 'abs');
        CreateSymbolicConstant('e', exp(1), junk);
    end;


procedure initExpressions;
    begin
        singleLetterVariables := false;
        implicitMultiplication := false;
        autoDeclareVariables := false;
        splitFunctions := false;
        parenthesesOnly := false;
        allowFactorials := false;
        caseSensitive := false;
        extraDataAfterExpression := false;
        ST := SymbolTableHandle(NewHandle(20 * SizeOf(SymbolTableNode)));
        ST_size := 20;
        ST_count := 0;
        ST_mark := -1;
        nameChars := ['a'..'z', 'A'..'Z', '0'..'9', '_'];
        AddBuiltInFunctions;
    end;

function CreateVariable (name: string;
                                val: extended): integer;
{ returns ref to variable for use in SetVariableName and SetVariableValue }
    var
        err: SymbolTableError;
        symb: integer;
    begin
{$PUSH}
{$R-}
        if length(name) > symbolNameMaxLength then
            name[0] := chr(symbolNameMaxLength);
{$POP}
        symb := CreateSymbol(name, variableSymbol, err);
        if err <> noSymbolTableError then
            CreateVariable := -1
        else begin
                CreateVariable := Symb;
                ST^^[symb].value := val;
            end;
    end;

procedure SetVariableValue (varRef: integer;
                                val: extended);
    begin
        if (varRef < 0) | (varRef >= ST_count) | (ST^^[varRef].kind <> variableSymbol) then
            EXIT(SetVariableValue);
        ST^^[varRef].value := val;
    end;

procedure SetVariableName (varRef: integer;
                                name: string);
{ for limited use--little error checking }
    begin
        if (varRef < 0) | (varRef >= ST_count) | (ST^^[varRef].kind <> variableSymbol) then
            EXIT(SetVariableName);
{$PUSH}
{$R-}
        if length(name) > symbolNameMaxLength then
            name[0] := chr(symbolNameMaxLength);
{$POP}
        ST^^[varRef].name := name;
    end;

procedure CreateSymbolicConstant (name: string;
                                value: extended;
                                var err: boolean);
    var
        STerr: SymbolTableError;
        symb: integer;
    begin
{$PUSH}
{$R-}
        if length(name) > symbolNameMaxLength then
            name[0] := chr(symbolNameMaxLength);
{$POP}
        symb := CreateSymbol(name, constantSymbol, STerr);
        if STerr <> noSymbolTableError then
            err := true
        else begin
                err := false;
                ST^^[symb].value := value;
            end;
    end;

{-------------------END OF  SYMBOL TABLE STUFF ------------------ }

function NewChars: CharsHandle;    { SOME CHARSHANDLE UTILITIES }
    begin
        NewChars := CharsHandle(NewHandle(0));
    end;

procedure MakeCharsEmpty (var Chars: CharsHandle);
    begin
        SetHandleSize(Handle(Chars), 0);
    end;

function CharsSize (Chars: CharsHandle): longint;
    begin
        CharsSize := GetHandleSize(handle(Chars));
    end;

procedure AddStringToChars (var Chars: CharsHandle;
                                str: string);
    var
        start, i: longint;
    begin
        start := GetHandleSize(handle(Chars));
        SetHandleSize(handle(Chars), start + length(str));
        if memError = noErr then
            for i := 1 to length(str) do
                Chars^^[start + i - 1] := str[i];
    end;


{---------------------String-reading procs-----------------------}

    const
        endOfDataToken = chr(0);
        errorToken = chr(1);
        numericToken = chr(2);
        badNumericToken = chr(3);
        caseToken = chr(4);
        endToken = chr(5);
        implicitStarToken = chr(6);


    var
        parseData: CharsPtr;
        parseSize: integer;
        pos: integer;
        tokenAvailable: boolean;
        theToken: SymbolName;
        tokenVal: extended;



function nextCh: char;
    begin
        if pos >= parseSize then
            nextCh := endOfDataToken
        else
            nextCh := parseData^[pos]
    end;

function getCh: char;
    begin
        if pos = parseSize then
            getCh := endOfDataToken
        else begin
                getCh := parseData^[pos];
                pos := pos + 1
            end;
    end;

procedure GetWord (var name: SymbolName);
{ assumes next char is a letter! }
    var
        ch: char;
        ct: integer;
        savePos: integer;
    begin
        ct := 0;
        name := '';
        savePos := pos;
        while (ct < SymbolNameMaxLength) & (nextCh in nameChars) do begin
                name := Concat(name, getCh);
                ct := ct + 1
            end;
        while (nextCh in nameChars) do
            ch := getCh;
        if EqualString(name, 'pi', false, false) then
            name := 'π'
        else if splitFunctions then begin
                if EqualString(name, 'case', false, false) then
                    name := caseToken
                else if EqualString(name, 'end', false, false) then
                    name := endToken
                else if EqualString(name, 'and', false, false) then
                    name := '&'
                else if EqualString(name, 'or', false, false) then
                    name := '|'
                else if EqualString(name, 'not', false, false) then
                    name := '~'
                else if singleLetterVariables & (FindSymb(name) = -1) then begin
                        name := name[1];
                        pos := savePos + 1;
                    end;
            end
        else if singleLetterVariables & (FindSymb(name) = -1) then begin
                name := name[1];
                pos := savePos + 1;
            end;
    end;

procedure GetNum (var val: extended;
                                var good: boolean);
    var
        num: string;
        ct: integer;
    begin
        num := '';
        good := false;
        while (length(num) < 255) & (nextCh in ['0'..'9']) do
            num := Concat(num, getCh);
        if nextCh = '.' then begin
                if num = '' then begin
                        num := getCh;
                        if not (nextCh in ['0'..'9']) then
                            EXIT(GetNum)  { '.' with no digits on either side of it }
                    end
                else if length(num) < 255 then
                    num := Concat(num, getCh)
            end;
        while (length(num) < 255) & (nextCh in ['0'..'9']) do
            num := Concat(num, getCh);
        if (length(num) < 255) & ((nextCh = 'e') | (nextCh = 'E')) then begin
                num := Concat(num, getCh);
                if (length(num) < 255) & ((nextCh = '-') | (nextCh = '+')) then
                    num := Concat(num, getCh);
                ct := 0;
                while (length(num) < 255) & (nextCh in ['0'..'9']) do begin
                        num := Concat(num, getCh);
                        ct := ct + 1
                    end;
                if (ct = 0) | (ct > 3) then
                    EXIT(GetNum);  { bad number of digits in exponent }
            end;
        if length(num) = 255 then
            EXIT(GetNum); {number too long}
        IOCheck(false);
        ReadString(num, val);
        IOCheck(true);
        if IOResult <> 0 then
            EXIT(GetNum); { something strange is wrong in the number }
        good := true;
    end;

procedure look (var token: SymbolName);
    var
        ch: char;
        good: boolean;
    begin
        if tokenAvailable then
            token := theToken
        else begin
                ch := nextCh;
                while ch in [' ', chr(9), chr(13), chr(3)] do begin
                        ch := getCh;
                        ch := nextCh;
                    end;
                if ch in ['0'..'9', '.'] then begin
                        GetNum(tokenVal, good);
                        if good then
                            theToken := numericToken
                        else
                            theToken := badNumericToken
                    end
                else if ch in ['a'..'z', 'A'..'Z'] then
                    GetWord(theToken)
                else if ch in [endOfDataToken, 'π', '+', '-', '*', '^', '/', '(', ')', '[', ']', '{', '}', '='] then
                    theToken := GetCh
                else if allowFactorials & (ch = '!') then
                    theToken := GetCh
                else if splitFunctions & (ch in ['~', '<', '>', '≥', '≤', '≠', '&', '|', ':', ';', ',']) then begin
                        theToken := getCh;
                        if (theToken = '>') & (nextCh = '=') then begin
                                theToken := '≥';
                                ch := getCh
                            end
                        else if (theToken = '<') & (nextCh = '=') then begin
                                theToken := '≤';
                                ch := getCh
                            end
                        else if (theToken = '<') & (nextCh = '>') then begin
                                theToken := '≠';
                                ch := getCh
                            end
                    end
                else begin
                        theToken := errorToken;
                        ch := getCh
                    end;
                token := theToken;
                tokenAvailable := true;
            end
    end;

procedure GetToken (var token: symbolName);
    begin
        Look(token);
        TokenAvailable := false;
    end;


{----------------end of tokenization procedures--------------------}
function RightBracket (left: char): char;
    begin
        if left = '(' then
            RightBracket := ')'
        else if left = '{' then
            RightBracket := '}'
        else if left = '[' then
            RightBracket := ']';
    end;

procedure DefineFunctionFromString (definition: string;
                                var errorPos: integer;
                                var errorMessage: string);
    begin
        if definition = '' then begin
                errorPos := 0;
                errorMessage := 'Empty input provided for function definition.';
            end
        else
            DefineFunction(@definition[1], length(definition), errorPos, errorMessage);
    end;

procedure DefineFunctionFromText (definition: CharsHandle;
                                var errorPos: integer;
                                var errorMessage: string);
    begin
        Hlock(Handle(definition));
        DefineFunction(Ptr(definition^), CharsSize(definition), errorPos, errorMessage);
        HUnlock(Handle(definition));
    end;

procedure DefineFunction (definition: Ptr;
                                charCt: integer;
                                var errorPos: integer;
                                var errorMessage: string);
    var
        name, tok: SymbolName;
        paramCt: integer;
        err: SymbolTableError;
        exp: expression;
        symb, func: integer;
        nameExists: boolean;
    procedure ExitWithError (message: string);
        begin
            errorPos := pos;
            errorMessage := message;
            FreeSymb;
            EXIT(DefineFunction);
        end;
    begin
        parseData := CharsPtr(definition);
        parseSize := charCt;
        pos := 0;
        TokenAvailable := false;
        GetToken(name);
        if not (name[1] in ['a'..'z', 'A'..'Z']) then
            ExitWithError('Illegal name specified for function begin defined.');
        symb := FindSymb(name);
        if symb = -1 then
            NameExists := false
        else if ST^^[symb].kind <> functionSymbol then
            ExitWithError('The name for the function being defined is already in use.')
        else begin
                NameExists := true;
                func := symb
            end;
        GetToken(tok);
        if tok <> '(' then
            ExitWithError('Expected a left parenthesis to begin the function''s argument list.');
        GetToken(tok);
        if not (tok[1] in ['a'..'z', 'A'..'Z']) then
            ExitWithError('Expected a name for the function''s first argument.');
        paramCt := 0;
        MarkSymb;
        repeat
            paramCt := paramCt + 1;
            if paramCt > 10 then
                ExitWithError('Too many arguments for this function; maximum is ten.');
            symb := CreateSymbol(tok, parameterSymbol, err);
            if err = lowMemory then
                ExitWithError('Ran out of memory.')
            else if err = symbolAlreadyExists then
                ExitWithError('You can''t have two arguments with the same name.');
            ST^^[symb].paramNum := paramCt;
            GetToken(tok);
            if (tok <> ',') & (tok <> ')') then
                ExitWithError('Expected either a comma or a right parenthesis.');
            if tok = ',' then begin
                    GetToken(tok);
                    if not (tok[1] in ['a'..'z', 'A'..'Z']) then
                        ExitWithError('Expected a name for the function''s next argument.');
                end;
        until tok = ')';
        look(tok);
        if tok = '=' then
            GetToken(tok);
        if nameExists & (ST^^[func].parameterCount <> paramCt) then
            ExitWithError('Attempt to redefine a function with a different number of arguments.');
        new(exp);
        definition := Ptr(longint(definition) + pos);
        exp.create(definition, charCt - pos, errorPos, errorMessage);
        FreeSymb;
        if errorPos >= 0 then begin
                errorPos := errorPos + pos;
                dispose(exp);
                Exit(DefineFunction);
            end;
        if not nameExists then begin
                func := CreateSymbol(name, functionSymbol, err);
                if err <> noSymbolTableError then begin
                        exp.kill;
                        ExitWithError('Ran out of memory.');
                    end;
            end;
        ST^^[func].parameterCount := paramCt;
        if nameExists then
            ST^^[func].definition.kill;
        ST^^[func].definition := exp;
    end;

procedure expression.create (definition: ptr;       { pointer to array[0...] of char }
                                charCount: integer;
                                var errorPosition: integer;   { -1 if no error }
                                var errorMessage: string); { unchanged if no error }
    var
        size: integer;
        exp: expressionListHandle;
    procedure ExitWithError (message: string);
        begin
            DisposHandle(data);
            errorPosition := pos;
            errorMessage := message;
            EXIT(create);
        end;
    function NewNode: integer;
        begin
            if count = size then begin
                    SetHandleSize(data, (size + 20) * SizeOf(expressionNode));
                    if memError <> noErr then
                        ExitWithError('There is not enough memory to create the expression.');
                    size := size + 20;
                end;
            exp^^[count].bracket := ' ';
            NewNode := count;
            count := count + 1;
        end;
    function CreateUnaryOpNode (theOp: unaryOpKinds;
                                    operand: integer): integer;
        var
            loc: integer;
        begin
            loc := NewNode;
            exp^^[loc].kind := unaryOpNode;
            exp^^[loc].theOp := theOp;
            exp^^[loc].operand := operand;
            CreateUnaryOpNode := loc;
        end;
    function CreateBinOpNode (theOp: binOpKinds;
                                    operand1, operand2: integer): integer;
        var
            loc: integer;
        begin
            loc := NewNode;
            exp^^[loc].kind := binOpNode;
            exp^^[loc].theBinOp := theOp;
            exp^^[loc].operand1 := operand1;
            exp^^[loc].operand2 := operand2;
            CreateBinOpNode := loc;
        end;
    procedure expression (var loc: integer;
                                    var logical: boolean);
    forward;
    procedure primary (var loc: integer;
                                    var logical: boolean);
        var
            tok, brak, saveTok: SymbolName;
            symb: integer;
            err: SymbolTableError;
            loc2, loc3, loc4, i: integer;
        procedure CheckBracket (saveTok, tok: SymbolName);
            begin
                if (saveTok = '(') then begin
                        if (tok <> ')') then
                            ExitWithError('Expected to find a ")" to match a previous "(".');
                    end
                else if (saveTok = '{') then begin
                        if (tok <> '}') then
                            ExitWithError('Expected to find a "}" to match a previous "{".');
                    end
                else if (saveTok = '[') then begin
                        if (tok <> ']') then
                            ExitWithError('Expected to find a "]" to match a previous "[".');
                    end;
            end;
        begin
            GetToken(tok);
            if tok = numericToken then begin
                    loc := NewNode;
                    exp^^[loc].kind := constantNode;
                    exp^^[loc].value := tokenVal;
                    logical := false;
                end
            else if tok = 'π' then begin
                    loc := NewNode;
                    exp^^[loc].kind := piNode;
                    logical := false;
                end
            else if tok[1] in ['a'..'z', 'A'..'Z'] then begin
                    logical := false;
                    symb := FindSymb(tok);
                    if symb = -1 then
                        if autoDeclareVariables then begin
                                symb := CreateSymbol(tok, variableSymbol, err);
                                if err <> noSymbolTableError then
                                    ExitWithError('Ran out of memory while trying to declare a new variable.');
                            end
                        else
                            ExitWithError('Unknown name found in expression.');
                    case ST^^[symb].kind of
                        variableSymbol:  begin
                                loc := NewNode;
                                exp^^[loc].kind := variableNode;
                                exp^^[loc].symbol := symb
                            end;
                        constantSymbol:  begin
                                loc := NewNode;
                                exp^^[loc].kind := symbolicConstantNode;
                                exp^^[loc].symbol := symb
                            end;
                        parameterSymbol:  begin
                                loc := NewNode;
                                exp^^[loc].kind := parameterNode;
                                exp^^[loc].number := ST^^[symb].paramNum
                            end;
                        functionSymbol, builtInFunctionSymbol:  begin
                                Look(brak);
                                if (brak <> '(') & (parenthesesOnly | ((brak <> '{') & (brak <> '['))) then
                                    if parenthesesOnly then
                                        ExitWithError('The argument to a function must be enclosed in parenthesis.')
                                    else
                                        ExitWithError('The argument to a function must be enclosed in parenthesis, brackets, or braces.');
                                if ST^^[symb].kind = builtInFunctionSymbol then begin
                                        GetToken(saveTok);
                                        expression(loc, logical);
                                        if logical then
                                            ExitWithError('The argument to a function cannot be a boolean value.');
                                        exp^^[loc].bracket := saveTok;
                                        GetToken(tok);
                                        CheckBracket(saveTok, tok);
                                        loc := CreateUnaryOpNode(ST^^[symb].theOp, loc);
                                    end
                                else begin
                                        GetToken(brak);
                                        loc := NewNode;
                                        exp^^[loc].kind := functNode;
                                        exp^^[loc].definition := symb;
                                        exp^^[loc].bracket := brak;
                                        loc2 := loc;
                                        for i := 1 to ST^^[symb].parameterCount do begin
                                                expression(loc3, logical);
                                                if logical then
                                                    ExitWithError('The argument to a function cannot be a boolean value.');
                                                loc4 := NewNode;
                                                exp^^[loc4].kind := actualParamNode;
                                                exp^^[loc4].param := loc3;
                                                exp^^[loc4].nextArgument := -1;
                                                if i = 1 then
                                                    exp^^[loc2].firstArgument := loc4
                                                else
                                                    exp^^[loc2].nextArgument := loc4;
                                                loc2 := loc4;
                                                GetToken(tok);
                                                if i < ST^^[symb].parameterCount then begin
                                                        if (tok = ')') | (tok = '}') | (tok = ']') then
                                                            ExitWithError('Not enough parameters provided for function.')
                                                        else if tok <> ',' then
                                                            ExitWithError('A comma is required between parameters of function.');
                                                    end
                                                else begin
                                                        if tok = ',' then
                                                            ExitWithError('Too many parameters provided for function.');
                                                    end;
                                            end;
                                        CheckBracket(saveTok, tok);
                                    end;
                            end;
                    end;
                end
            else if (tok = '(') | (not parenthesesOnly & ((tok = '{') | (tok = '['))) then begin
                    saveTok := tok;
                    expression(loc, logical);
                    exp^^[loc].bracket := saveTok;
                    GetToken(tok);
                    if (saveTok = '(') then begin
                            if (tok <> ')') then
                                ExitWithError('Expected to find a ")" to match a previous "(".');
                        end
                    else if (saveTok = '{') then begin
                            if (tok <> '}') then
                                ExitWithError('Expected to find a "}" to match a previous "{".');
                        end
                    else if (saveTok = '[') then begin
                            if (tok <> ']') then
                                ExitWithError('Expected to find a "]" to match a previous "[".');
                        end
                end
            else if tok = caseToken then begin
                    loc2 := -1;
                    loc := NewNode;
                    i := loc;
                    repeat
                        exp^^[i].kind := splitFunctionNode;
                        expression(loc3, logical);
                        if not logical then
                            ExitWithError('The conditions in a split function must be boolean expressions.');
                        GetToken(tok);
                        if tok <> ':' then
                            ExitWithError('The condition in a split function must be followed by a ":".');
                        expression(loc4, logical);
                        if logical then
                            ExitWithError('You can''t use a boolean expression to compute the value of a split function.');
                        if loc2 <> -1 then
                            exp^^[loc2].nextCase := i;
                        exp^^[i].kind := splitFunctionNode;
                        exp^^[i].theTest := loc3;
                        exp^^[i].theExpression := loc4;
                        exp^^[i].nextCase := -1;
                        loc2 := i;
                        GetToken(tok);
                        if tok = ';' then begin
                                look(tok);
                                if Tok = endToken then
                                    GetToken(tok);
                            end
                        else if tok <> endToken then
                            ExitWithError('You need either a ";" or an "end" here.');
                        if tok <> endToken then
                            i := NewNode;
                    until tok = endToken;
                end
            else if tok = endOfDataToken then
                ExitWithError('Incomplete expression; end of data found in middle of expression.')
            else if tok = badNumericToken then
                ExitWithError('An illegally formed number was found.')
            else if tok = errorToken then
                ExitWithError('Illegal item found in expression.')
            else
                ExitWithError('Misplaced symbol found in expression.');
        end;
    procedure factorial (var loc: integer;
                                    var logical: boolean);
        var
            next: integer;
            tok: SymbolName;
        begin
            primary(loc, logical);
            if allowFactorials then begin
                    look(tok);
                    if (tok = '!') & logical then
                        ExitWithError('You can''t use the factorial operation on a boolean expression.');
                    while tok = '!' do begin
                            GetToken(tok);
                            loc := CreateUnaryOpNode(factorialOp, loc);
                            look(tok);
                        end;
                end;
        end;
    procedure factor (var loc: integer;
                                    var logical: boolean);
        var
            next: integer;
            tok: SymbolName;
        begin
            factorial(loc, logical);
            look(tok);
            if logical & (tok = '^') then
                ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
            while tok = '^' do begin
                    GetToken(tok);
                    factorial(next, logical);
                    if logical then
                        ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
                    loc := CreateBinOpNode(powerOp, loc, next);
                    look(tok);
                end;
        end;
    procedure term (var loc: integer;
                                    var logical: boolean);
        var
            next: integer;
            tok: SymbolName;
        begin
            factor(loc, logical);
            look(tok);
            if implicitMultiplication & (tok[1] in ['a'..'z', 'A'..'Z', '0'..'9', '[', '{', '(', numericToken]) then
                tok := implicitStarToken;
            if logical & ((tok = '*') | (tok = '/') | (tok = implicitStarToken)) then
                ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
            while (tok = '*') | (tok = '/') | (tok = implicitStarToken) do begin
                    if tok <> implicitStarToken then
                        GetToken(tok);
                    factor(next, logical);
                    if logical then
                        ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
                    if tok = '/' then
                        loc := CreateBinOpNode(divideOp, loc, next)
                    else
                        loc := CreateBinOpNode(timesOp, loc, next);
                    look(tok);
                    if implicitMultiplication & (tok[1] in ['a'..'z', 'A'..'Z', '0'..'9', '[', '{', '(', numericToken]) then
                        tok := implicitStarToken;
                end;
        end;
    procedure basicExp (var loc: integer;
                                    var logical: boolean);
        var
            next: integer;
            tok, leadingTok: SymbolName;
        begin
            look(leadingTok);
            if (leadingTok = '+') | (leadingTok = '-') then
                GetToken(tok);
            term(loc, logical);
            if (leadingTok = '+') | (leadingTok = '-') then begin
                    if logical then
                        ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
                    if leadingTok = '-' then
                        loc := CreateunaryOpNode(unaryMinusOp, loc);
                end;
            look(tok);
            if logical & ((tok = '+') | (tok = '-')) then
                ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
            while (tok = '+') | (tok = '-') do begin
                    GetToken(tok);
                    term(next, logical);
                    if logical then
                        ExitWithError('You can''t use a boolean expression with an arithmetic operator.');
                    if tok = '+' then
                        loc := CreateBinOpNode(plusOp, loc, next)
                    else
                        loc := CreateBinOpNode(minusOp, loc, next);
                    look(tok);
                end;
        end;
    procedure comparison (var loc: integer;
                                    var logical: boolean);
        var
            loc2: integer;
            tok: SymbolName;
            theOp: binOpKinds;
        begin
            BasicExp(loc, logical);
            look(tok);
            if tok[1] in ['<', '>', '=', '≤', '≥', '≠'] then begin
                    if logical then
                        ExitWithError('You can''t apply a comparison operator to a boolean expression.');
                    GetToken(tok);
                    BasicExp(loc2, logical);
                    if logical then
                        ExitWithError('You can''t apply a comparison operator to a boolean expression.');
                    case tok[1] of
                        '<':
                            theOp := ltOp;
                        '>':
                            theOp := gtOp;
                        '=':
                            theOp := eqOp;
                        '≤':
                            theOp := leOp;
                        '≥':
                            theOp := geOp;
                        '≠':
                            theOp := neOp;
                    end;
                    loc := CreateBinOpNode(theOp, loc, loc2);
                    logical := true;
                end;
        end;
    procedure NotExp (var loc: integer;
                                    var logical: boolean);
        var
            next: integer;
            tok: SymbolName;
            ct: integer;
        begin
            ct := 0;
            look(tok);
            while tok = '~' do begin
                    GetToken(tok);
                    ct := ct + 1;
                    look(tok);
                end;
            if ct = 0 then
                comparison(loc, logical)
            else begin
                    comparison(loc, logical);
                    if not logical then
                        ExitWithError('You can''t use the NOT operator on an arithmetic expression.');
                    if odd(ct) then
                        loc := CreateUnaryOpNode(notOp, loc);
                end;
        end;
    procedure andExp (var loc: integer;
                                    var logical: boolean);
        var
            next: integer;
            tok: SymbolName;
        begin
            notExp(loc, logical);
            look(tok);
            if not logical & (tok = '&') then
                ExitWithError('You can''t use a boolean operator with an arithmetic expression.');
            while tok = '&' do begin
                    GetToken(tok);
                    notExp(next, logical);
                    if not logical then
                        ExitWithError('You can''t use a boolean operator with an arithmetic expression.');
                    loc := CreateBinOpNode(andOp, loc, next);
                    look(tok);
                end;
        end;
    procedure expression (var loc: integer;
                                    var logical: boolean);
        var
            next: integer;
            tok: SymbolName;
        begin
            andExp(loc, logical);
            look(tok);
            if not logical & (tok = '|') then
                ExitWithError('You can''t use a boolean operator with an arithmetic expression.');
            while tok = '|' do begin
                    GetToken(tok);
                    andExp(next, logical);
                    if not logical then
                        ExitWithError('You can''t use a boolean operator with an arithmetic expression.');
                    loc := CreateBinOpNode(orOp, loc, next);
                    look(tok);
                end;
        end;
        var
            logical: boolean;
            tok: SymbolName;
            loc: integer;
    begin
        parseData := CharsPtr(definition);
        parseSize := charCount;
        pos := 0;
        tokenAvailable := false;
        data := NewHandle(10 * SizeOf(expressionNode));
        exp := ExpressionListHandle(data);
        if memError <> noErr then begin
                errorPosition := 0;
                errorMessage := 'There is not enough memory to create expression.';
                EXIT(create);
            end;
        size := 10;
        count := 0;
        expression(loc, logical);
        first := loc;
        if logical then
            ExitWithError('A boolean-valued expression is not legal here.');
        Look(tok);
        if (tok <> EndOfDataToken) & not extraDataAfterExpression then
            ExitWithError('Extra data found after the end of the expression.');
        SetHandleSize(data, count * SizeOf(expressionNode));
        errorPosition := -1;
    end;

procedure expression.createFromString (definition: string;
                                var errorPosition: integer;   { -1 if no error }
                                var errorMessage: string);
    begin
        if definition = '' then begin
                errorPosition := 0;
                errorMessage := 'Empty input provided for expression definition.';
            end
        else
            create(@definition[1], length(definition), errorPosition, errorMessage);
    end;

procedure expression.createFromText (definition: CharsHandle;
                                var errorPosition: integer;   { -1 if no error }
                                var errorMessage: string);
    begin
        HLock(Handle(definition));
        create(Pointer(definition^), CharsSize(definition), errorPosition, errorMessage);
        HUnlock(Handle(definition));
    end;
{$PUSH}
{$R-}


{$S ExtraExpressionStuff }

procedure RealToString (x: extended;
                                var s: string);
    var
        n, i: integer;
    begin
        if x = errorVal then
            s := '(ERROR)'
        else if abs(x) <= infinityRecip then
            s := '0'
        else if abs(x) >= infinity then
            s := '?'
        else if (abs(x) >= 5e8) or (abs(x) < 5e-8) then begin  { exponential form }
                n := 15;
                repeat  { this is needed since the stupid computer alllows 4 spaces for the exponent even if it is one two or three digits }
                    s := StringOf(x : n);
                    n := n - 1;
                    i := length(s);
                    while (i > 0) & (s[i] = ' ') do
                        i := i - 1;
                    s[0] := chr(i);
                until (length(s) <= 12) | (n = 11)
            end
        else begin
                s := StringOf(x : 1 : 10);
                i := length(s);
                while (i > 0) & (s[i] = '0') do   { strip off trailing zeros }
                    i := i - 1;
                if (i > 0) & (s[i] = '.') then  { strip off terminating decimal point }
                    i := i - 1;
                if i > 12 then  { maximum length allowed for output is 12}
                    s[0] := chr(12)
                else
                    s[0] := chr(i);
            end
    end;

{$POP}

procedure expression.GetPrintText (var theText: CharsHandle);
    var
        countCh: integer;
        exp: ExpressionListHandle;
    procedure AddString (str: string);
        var
            i: integer;
        begin
            if countCh + length(str) > GetHandleSize(handle(theText)) then
                SetHandleSize(handle(theText), countCh + length(str) + 25);
            if memError <> noErr then begin
                    SetHandleSize(handle(theText), count);
                    EXIT(GetPrintText);
                end;
            for i := 1 to length(str) do begin
                    theText^^[countCh] := str[i];
                    countCh := countCh + 1;
                end;
        end;
    function BinName (op: BinOpKinds): string;
        begin
            case op of
                plusOp:
                    BinName := ' + ';
                minusOp:
                    BinName := ' - ';
                timesOp:
                    BinName := '*';
                divideOp:
                    BinName := '/';
                powerOp:
                    BinName := '^';
                andOp:
                    BinName := ' AND ';
                orOp:
                    BinName := ' OR ';
                leOp:
                    BinName := ' ≤ ';
                ltOp:
                    BinName := ' < ';
                geOp:
                    BinName := ' ≥ ';
                gtOp:
                    BinName := ' > ';
                eqOp:
                    BinName := ' = ';
                neOp:
                    BinName := ' ≠ ';
            end;
        end;
    function UnaryName (op: UnaryOpKinds): string;
        begin
            case op of
                unaryMinusOp:
                    UnaryName := '-';
                notOp:
                    UnaryName := ' NOT ';
                sinOp:
                    UnaryName := 'sin';
                cosOp:
                    UnaryName := 'cos';
                tanOp:
                    UnaryName := 'tan';
                cotOp:
                    UnaryName := 'cot';
                secOp:
                    UnaryName := 'sec';
                cscOp:
                    UnaryName := 'csc';
                arcsinOp:
                    UnaryName := 'arcsin';
                arctanOp:
                    UnaryName := 'arctan';
                expOp:
                    UnaryName := 'exp';
                lnOp:
                    UnaryName := 'ln';
                roundOp:
                    UnaryName := 'round';
                truncOp:
                    UnaryName := 'trunc';
                sqrtOp:
                    UnaryName := 'sqrt';
                cubertOp:
                    UnaryName := 'cubeRt';
                absOp:
                    UnaryName := 'abs';
            end;
        end;
    procedure MakeStr (loc: integer);
        var
            i, symb, prm: integer;
            name: SymbolName;
            str: string;
        begin
            if (exp^^[loc].bracket <> ' ') & (exp^^[loc].kind <> functNode) then
                AddString(exp^^[loc].bracket);
            case exp^^[loc].kind of
                binOpNode:  begin
                        MakeStr(exp^^[loc].operand1);
                        AddString(BinName(exp^^[loc].theBinOp));
                        MakeStr(exp^^[loc].operand2);
                    end;
                unaryOpNode:
                    if exp^^[loc].theOp = factorialOp then begin
                            MakeStr(exp^^[loc].operand);
                            AddString('!');
                        end
                    else begin
                            AddString(UnaryName(exp^^[loc].theOp));
                            MakeStr(exp^^[loc].operand);
                        end;
                functNode:  begin
                        symb := exp^^[loc].definition;
                        name := ST^^[symb].name;
                        AddString(name);
                        AddString(exp^^[loc].bracket);
                        prm := exp^^[loc].firstArgument;
                        for i := 1 to ST^^[symb].paramNum do begin
                                if exp^^[prm].kind <> actualParamNode then
                                    Halt; { ??? }
                                MakeStr(exp^^[prm].Param);
                                if i < ST^^[symb].paramNum then begin
                                        AddString(', ');
                                        prm := exp^^[prm].nextArgument;
                                    end;
                            end;
                        AddString(RightBracket(exp^^[loc].bracket))
                    end;
                splitFunctionNode:  begin
                        AddString(' CASE ');
                        i := loc;
                        repeat
                            MakeStr(exp^^[i].theTest);
                            AddString(' : ');
                            MakeStr(exp^^[i].theExpression);
                            i := exp^^[i].nextCase;
                            if i >= 0 then
                                AddString(';  ');
                        until i < 0;
                        AddString(' END ');
                    end;
                variableNode, symbolicConstantNode:  begin
                        name := ST^^[exp^^[loc].symbol].name;
                        AddString(name);
                    end;
                constantNode:  begin
                        RealToString(exp^^[loc].value, str);
                        AddString(str);
                    end;
                piNode:
                    AddString('π');
            end;
            if (exp^^[loc].bracket <> ' ') & (exp^^[loc].kind <> functNode) then
                AddString(RightBracket(exp^^[loc].bracket));
        end;
    begin
        countCh := 0;
        exp := ExpressionListHandle(data);
        MakeStr(first);
        SetHandleSize(handle(theText), countCh);
    end;

procedure expression.GetPrintString (var str: string;
                                var lengthExceeded: boolean);
    var
        theText: CharsHandle;
        i: integer;
        top: longint;
    begin
        theText := CharsHandle(NewHandle(25));
        GetPrintText(theText);
        top := GetHandleSize(Handle(theText));
        if top > 255 then begin
                lengthExceeded := true;
                top := 255;
            end
        else
            lengthExceeded := false;
        str := '';
        for i := 0 to top - 1 do
            str := Concat(str, theText^^[i]);
        DisposHandle(Handle(theText));
    end;

procedure expression.kill;
    begin
        DisposHandle(data);
        data := nil;
        dispose(self);
    end;

function power (x: extended;
                                n: integer): extended;
{ compute x^n;  n MUST be >= 0 !!!}
    var
        v: extended;
    begin
        v := 1;
        while n > 0 do begin
                if odd(n) then begin
                        v := v * x;
                        if abs(v) > infinity then begin
                                v := infinity;
                                leave
                            end;
                    end;
                n := Bsr(n, 1);
                x := sqr(x);
            end;
        power := v;
    end;


    type
        intListArray = array[0..100] of integer;
        intListPtr = ^IntListArray;
        intListHandle = ^IntListPtr;
        ParamData = array[1..10] of extended;


function computeValue (e: expressionListHandle;
                                first: integer;
                                var cases: Handle;
                                var caseCt, caseSize: integer;
                                var context: ParamData): extended;
    var
        caseData: IntListHandle;
        i, j, k: integer;
    function GetVal (loc: integer): extended;
        var
            theCase: longint;
        function BinVal (op: binOpKinds;
                                        x, y: extended): extended;
            var
                temp: extended;
                Apply2: extended;
            begin
                if op = orOp then begin
                        if x <> 0 then
                            Apply2 := x
                        else
                            Apply2 := y
                    end
                else if op = andOp then begin
                        if (x = 0) then
                            Apply2 := 0
                        else
                            Apply2 := y
                    end
                else begin
                        if (x = errorVal) or (y = errorVal) then begin
                                if op in [eqOp, ltOp, gtOp, NEOp, LEOp, GEOp] then
                                    Apply2 := 0
                                else
                                    Apply2 := errorVal;
                            end
                        else if (x = infinity) or (y = infinity) then begin
                                if op in [eqOp, ltOp, gtOp, NEOp, LEOp, GEOp] then
                                    Apply2 := 0
                                else
                                    Apply2 := infinity;
                            end
                        else if op in [plusOp, minusOp, timesOp, powerOp, divideOp] then begin
                                case op of
                                    plusOp:
                                        temp := x + y;
                                    minusOP:
                                        temp := x - y;
                                    timesOp:
                                        temp := x * y;
                                    divideOp:
                                        if (abs(y) < infinityRecip) | (abs(x) > abs(infinity * y)) then begin
                                                temp := infinity;
                                                theCase := 0;
                                            end
                                        else begin
                                                temp := x / y;
                                                theCase := ord(y > 0)
                                            end;
                                    powerOp:
                                        if abs(y) <= infinityRecip then begin
                                                if abs(x) <= infinityRecip then begin
                                                        temp := infinity;
                                                        theCase := 0;
                                                    end
                                                else begin
                                                        temp := 1;
                                                        theCase := ord(x > 0)
                                                    end
                                            end
                                        else if (abs(y) <= 32000) & (abs(round(y) - y) < 1e-5) then begin
                                                temp := power(x, abs(round(y)));
                                                if y < 0 then
                                                    if abs(temp) < infinityRecip then
                                                        temp := infinity
                                                    else
                                                        temp := 1 / temp;
                                                if y < 0 then
                                                    if x = 0 then
                                                        theCase := 0
                                                    else
                                                        theCase := ord(x > 0);
                                            end
                                        else begin
                                                if x = 0 then begin
                                                        temp := 0;
                                                        theCase := 0
                                                    end
                                                else if x < 0 then begin
                                                        temp := errorVal;
                                                        theCase := -1
                                                    end
                                                else begin
                                                        temp := y * ln(x);
                                                        if temp < -4000 then
                                                            temp := 0
                                                        else if temp > 4000 then
                                                            temp := infinity
                                                        else
                                                            temp := exp(temp);
                                                        theCase := 1
                                                    end;
                                            end;
                                end;
                                if abs(temp) > infinity then
                                    Apply2 := infinity
                                else
                                    Apply2 := temp
                            end
                        else
                            case op of
                                eqOp:
                                    Apply2 := ord(x = y);
                                ltOp:
                                    Apply2 := ord(x < y);
                                gtOp:
                                    Apply2 := ord(x > y);
                                GEOp:
                                    Apply2 := ord(x >= y);
                                LEOp:
                                    Apply2 := ord(x <= y);
                                NEOp:
                                    Apply2 := ord(x <> y);
                            end
                    end;
                BinVal := Apply2
            end;
        function UnaryVal (op: unaryOpKinds;
                                        x: extended): extended;
       { handle the evaluation of a unary operator or built-in function at x}
            var
                temp: extended;
                i: integer;
                apply1: extended;
            begin
                if (abs(x) >= infinity) then
                    Apply1 := x
                else begin
                        case op of
                            unaryMinusOp:
                                Apply1 := -x;
                            factorialOp:  begin
                                    if (x < -infinityRecip) | (x > 1000) | (abs(x - round(x)) > 1e-10) then begin
                                            apply1 := errorVal;
                                            theCase := 1000;
                                        end
                                    else begin
                                            apply1 := 1;
                                            for i := 2 to round(x) do begin
                                                    apply1 := apply1 * i;
                                                    if apply1 > infinity then begin
                                                            apply1 := infinity;
                                                            leave;
                                                        end;
                                                end;
                                            theCase := round(x);
                                        end
                                end;
                            sinOp:
                                Apply1 := sin(x);
                            cosOp:
                                Apply1 := cos(x);
                            secOp:  begin
                                    temp := cos(x);
                                    if abs(temp) <= infinityRecip then begin
                                            Apply1 := infinity;
                                            theCase := 0
                                        end
                                    else begin
                                            Apply1 := 1 / temp;
                                            theCase := ord(temp > 0)
                                        end;
                                end;
                            cscOp:  begin
                                    temp := sin(x);
                                    if abs(temp) <= infinityRecip then begin
                                            Apply1 := infinity;
                                            theCase := 0;
                                        end
                                    else begin
                                            Apply1 := 1 / temp;
                                            theCase := ord(temp > 0)
                                        end;
                                end;
                            tanOp:  begin
                                    temp := cos(x);
                                    if abs(temp) <= infinityRecip then begin
                                            Apply1 := infinity;
                                            theCase := 0;
                                        end
                                    else begin
                                            Apply1 := sin(x) / temp;
                                            theCase := ord(temp > 0)
                                        end;
                                end;
                            cotOp:  begin
                                    temp := sin(x);
                                    if abs(temp) <= infinityRecip then begin
                                            Apply1 := infinity;
                                            theCase := 0
                                        end
                                    else begin
                                            Apply1 := cos(x) / temp;
                                            theCase := ord(temp > 0)
                                        end;
                                end;
                            arctanOp:
                                Apply1 := arctan(x);
                            arcsinOp:
                                if abs(x) > 1 then begin
                                        Apply1 := errorVal;
                                        theCase := 0
                                    end
                                else begin
                                        theCase := 1;
                                        if abs(x - 1) < 1e-10 then
                                            Apply1 := 2 * arctan(1)
                                        else if abs(x + 1) < 1e-10 then
                                            Apply1 := -2 * arctan(1)
                                        else
                                            Apply1 := arctan(x / sqrt(1 - sqr(x)));
                                    end;
                            lnOp:  begin
                                    if x <= 0 then
                                        Apply1 := errorVal
                                    else
                                        Apply1 := ln(x);
                                    theCase := ord(x > 0);
                                end;
                            expOp:
                                if x > 4000 then
                                    Apply1 := infinity
                                else if x < -4000 then
                                    Apply1 := 0
                                else
                                    Apply1 := exp(x);
                            absOp:  begin
                                    Apply1 := abs(x);
                                    if x = 0 then
                                        theCase := 0
                                    else
                                        theCase := ord(x > 0)
                                end;
                            truncOp:
                                if abs(x) >= Maxlongint - 1 then
                                    Apply1 := errorVal
                                else begin
                                        Apply1 := trunc(x);
                                        theCase := trunc(x)
                                    end;
                            roundOp:
                                if abs(x) >= Maxlongint - 1 then
                                    Apply1 := errorVal
                                else begin
                                        Apply1 := round(x);
                                        theCase := round(x)
                                    end;
                            sqrtOp:  begin
                                    if x < 0 then
                                        Apply1 := errorVal
                                    else
                                        Apply1 := sqrt(x);
                                    theCase := ord(x >= 0);
                                end;
                            cubertOp:
                                if abs(x) < infinityRecip then
                                    Apply1 := 0
                                else if x < 0 then
                                    Apply1 := -exp(ln(-x) / 3)
                                else
                                    Apply1 := exp(ln(x) / 3);
                        end;
                        if (abs(x) >= infinity) & (x <> errorVal) then
                            UnaryVal := infinity
                        else
                            UnaryVal := apply1
                    end;
            end;
        function FunctVal: extended;
            var
                newContext: ParamData;
                symb, i, ct: integer;
            begin
                symb := e^^[loc].definition;
                i := e^^[loc].firstArgument;
                for ct := 1 to ST^^[symb].parameterCount do begin
                        newcontext[ct] := GetVal(e^^[i].param);
                        i := e^^[i].nextArgument;
                    end;
                with ST^^[symb].definition do
                    FunctVal := ComputeValue(expressionListHandle(data), first, cases, caseCt, caseSize, newcontext);
            end;
            var
                x, y: extended;
                uOp: unaryOpKinds;
                bOp: BinOpkinds;
                symb: integer;
                done: boolean;
                ct, i: integer;
        begin
            theCase := maxlongint;
            case e^^[loc].kind of
                binOpNode:  begin
                        x := GetVal(e^^[loc].operand1);
                        y := GetVal(e^^[loc].operand2);
                        bOp := e^^[loc].theBinOP;
                        GetVal := BinVal(bOp, x, y);
                    end;
                unaryOpNode:  begin
                        x := GetVal(e^^[loc].operand);
                        uOp := e^^[loc].theOp;
                        GetVal := UnaryVal(uOp, x);
                    end;
                constantNode:
                    GetVal := e^^[loc].value;
                variableNode, symbolicConstantNode:  begin
                        symb := e^^[loc].symbol;
                        GetVal := ST^^[symb].value
                    end;
                splitFunctionNode:  begin
                        ct := 0;
                        done := false;
                        repeat
                            i := e^^[loc].theTest;
                            done := GetVal(i) <> 0;
                            if done then
                                GetVal := GetVal(e^^[loc].theExpression)
                            else
                                loc := e^^[loc].nextCase;
                            ct := ct + 1;
                        until done | (loc = -1);
                        if loc = -1 then
                            GetVal := errorVal;
                        theCase := ct;
                    end;
                functNode:
                    GetVal := FunctVal;
                parameterNode:
                    GetVal := context[e^^[loc].number];
                piNode:
                    GetVal := pi;
            end;
            if (cases <> nil) & (theCase <> maxlongint) then begin
                    if caseSize = caseCt then begin
                            caseSize := caseSize + 20;
                            SetHandleSize(cases, caseSize * SizeOf(Integer));
                        end;
                    if abs(theCase) > maxint then
                        theCase := maxint;
                    caseData^^[caseCt] := theCase;
                    caseCt := caseCt + 1;
                end;
        end;
    begin
        caseData := IntListHandle(cases);
        ComputeValue := getVal(first);
    end;

function expression.value: extended;
    var
        noCases: handle;
        junk: paramData;
    begin
        noCases := nil;
        value := ValueWithCases(noCases)
    end;

function expression.valueWithCases (var cases: handle): extended;
    var
        junk: paramData;
        casesCt, casesSize: integer;
    begin
        if cases <> nil then
            SetHandleSize(cases, 10 * SizeOf(Integer));
        casesCt := 0;
        casesSize := 10;
        valueWithCases := ComputeValue(expressionListHandle(self.data), self.first, cases, casesCt, casesSize, junk);
        if cases <> nil then
            SetHandleSize(cases, casesCt * SizeOf(Integer));
    end;


function sameCases (cases1, cases2: handle): boolean;
    var
        ct, i: integer;
    begin
        ct := GetHandleSize(cases1);
        if (ct <> GetHandleSize(cases2)) | (ct mod SizeOf(Integer) <> 0) then
            sameCases := false
        else begin
                sameCases := true;
                for i := 0 to (ct div SizeOf(Integer)) - 1 do
                    if intListHandle(cases1)^^[i] <> intListHandle(cases2)^^[i] then begin
                            sameCases := false;
                            Exit(sameCases);
                        end;
            end;
    end;

function expression.isConstant: boolean;
    var
        e: ExpressionListHandle;
    function constant (loc: integer): boolean;
        var
            def: integer;
        begin
            case e^^[loc].kind of
                binOpNode:
                    constant := constant(e^^[loc].operand1) & constant(e^^[loc].operand2);
                unaryOpNode:
                    constant := constant(e^^[loc].operand);
                functNode:  begin
                        def := e^^[loc].definition;
                        loc := e^^[loc].firstArgument;
                        while loc <> -1 do
                            if constant(e^^[loc].param) then
                                loc := e^^[loc].nextArgument
                            else begin
                                    constant := false;
                                    EXIT(constant)
                                end;
                        constant := true;
                    end;
                splitFunctionNode:  begin
                        if not (constant(e^^[loc].theTest) & constant(e^^[loc].theExpression)) then
                            constant := false
                        else if e^^[loc].nextCase = -1 then
                            constant := true
                        else
                            constant := constant(e^^[loc].nextCase);
                    end;
                variableNode:
                    constant := false;
                symbolicConstantNode, constantNode, piNode:
                    constant := true;
            end;
        end;
    begin
        e := ExpressionListHandle(data);
        isConstant := constant(first);
    end;


end.